home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / vm_port.t < prev    next >
Text File  |  1988-02-05  |  15KB  |  448 lines
  1. (herald vm_port
  2.         (env tsys (osys buffer)))
  3.  
  4. ;++ how to include e.g. Aegis_file.t in above? Logical names?
  5.  
  6. ;;; The VM-system I/O and file routines.
  7.  
  8. ;;; This file contains the virtual machine I/O interface.  An I/O
  9. ;;; buffer (IOB) is a system independent way to represent an open
  10. ;;; file, among other things.
  11.  
  12. ;;; Character ports with current position information.
  13. ;;; Note: tab characters count as one horizontal position.
  14.  
  15. ;++ All procedures in this file should be checking their arguments.
  16. ;++ They should also be checking the IOB-MODE to ensure that the
  17. ;++ operation is valid for that iob.
  18.  
  19. ;++ Buffers will eventually have both read and write offsets, and
  20. ;++ update mode will be available, along with seeking and telling.
  21.  
  22. ;;; End of file exception and object.
  23.  
  24. ;++(define-exception (end-of-file port)
  25. ;++  (ignore port)
  26. ;++  eof)
  27.  
  28.  
  29. (define eof
  30.   (object nil
  31.     ((print self port) (write-string port "#{End-of-file}"))))
  32.  
  33. (define-integrable (end-of-file port) (ignore port) eof)
  34.  
  35. ;;; Input
  36.  
  37. ;;; Internal used by retriever.  (This could be hand optimized (made
  38. ;;; a primop) if that became important.)
  39.  
  40. (define-recursive (VM-READ-BYTE iob)
  41.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  42.          (let ((c (bref (iob-buffer iob) (iob-offset iob))))
  43.            (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  44.            c))
  45.         (else
  46.          (if (eof? ((iob-underflow iob) iob nil))
  47.              (end-of-file iob)
  48.              (vm-read-byte iob)))))
  49.  
  50. ;;; VM-READ-CHAR need not check for closed channels.  See
  51. ;;; CLOSE-port for an explanation.  (This could be hand optimized
  52. ;;; (made a primop) if it became important.)
  53.  
  54. (define-recursive (VM-READ-CHAR iob)
  55.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  56.          (let ((c (text-elt (iob-buffer iob) (iob-offset iob))))
  57.            (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  58.            ;++ the #\newline isn't portable?
  59.            (cond ((charN= c #\newline)
  60.                   (set (iob-h iob) (fx+ (iob-h iob) 1)))
  61.                  (else
  62.                   (set (iob-v iob) (fx+ (iob-v iob) 1))
  63.                   (set (iob-prev-h iob) (iob-h iob))
  64.                   (set (iob-h iob) 0)))
  65.            c))
  66.         (else
  67.          (if (eof? ((iob-underflow iob) iob nil))
  68.              (end-of-file iob)
  69.              (vm-read-char iob)))))
  70.  
  71. (define-recursive (VM-MAYBE-READ-CHAR iob)
  72.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  73.          (vm-read-char iob))
  74.         (else
  75.          (let ((val ((iob-underflow iob) iob t)))
  76.            (cond ((eof? val)   (end-of-file iob))
  77.                  ((false? val) nil)
  78.                  (else
  79.                   (vm-read-char iob)))))))
  80.  
  81. ;;; Returns the last character read.  This procedure can only be
  82. ;;; called once without rereading the character.  UNREAD-CHAR cannot
  83. ;;; be called after calling PEEK-CHAR - this is a bug and should
  84. ;;; be fixed.  UNREAD-CHAR is probably more useful in writing
  85. ;;; recursive decent parsers then PEEK-CHAR (explain).  Note: it
  86. ;;; is an error (currently undetected) to unread and EOF.
  87.  
  88. (define (VM-UNREAD-CHAR iob)
  89.   (cond ((fx> (iob-offset iob) 0)
  90.          (cond ((iob-eof-flag? iob))
  91.                (else
  92.                 (set (iob-offset iob) (fx- (iob-offset iob) 1))
  93.                 (cond ((char= (text-elt (iob-buffer iob) (iob-offset iob))
  94.                               #\newline)
  95.                        (set (iob-h iob) (iob-prev-h iob))
  96.                        (set (iob-v iob) (fx- (iob-v iob) 1)))
  97.                       (else 
  98.                        (set (iob-h iob) (fx- (iob-h iob) 1)))))))
  99.         (else
  100.          ;; This could be made to work but it hardly seems worth
  101.          ;; the effort.
  102.          (non-continuable-error
  103.           "consecutive attempt to UNREAD-CHAR on ~a" iob)))
  104.    (no-value))
  105.  
  106. ;;; This procedure can be called any number of times.
  107.  
  108. (define (VM-PEEK-CHAR IOB)
  109.   (let ((val (vm-read-char iob)))
  110.     (cond ((eof? val)
  111.            (end-of-file iob))
  112.           (else
  113.            (vm-unread-char iob)
  114.            val))))
  115.  
  116. ;;; Block input
  117.  
  118. ;;; Note: VM-READ-BLOCK allows reading of zero length blocks.
  119. ;++ use vm-read-partial-block to do this.
  120. ;++ fix to use VM-READ-PARTIAL-BLOCK
  121.  
  122. (define (make-extend-locative extend offset length)
  123.   (let ((ptr (make-string 0)))
  124.     (set (extend-elt ptr 0)   extend)
  125.     (set (string-offset ptr) offset)
  126.     (set (string-length ptr) length)
  127.     ptr))
  128.  
  129. (define (old-VM-READ-BLOCK IOB EXTEND SIZE)
  130.   (let ((size (enforce nonnegative-fixnum? size)))
  131.     (iterate loop ((i 0))                         
  132.       (cond ((fx>= i  size) i)
  133.             (else
  134.              (let ((val (vm-read-byte iob)))
  135.                (cond ((eof? val)
  136.                       (if (fx> i 0) i (end-of-file iob)))
  137.                      (else
  138.                       (set (bref extend i) val)
  139.                       (loop (fx+ i 1))))))))))
  140.  
  141. ;++ doesn't handle hpos or vpos
  142. (define (vm-read-block iob extend size)
  143.   (let* ((offset
  144.           (iterate loop ((i 0))
  145.             (cond ((and (fx< i size)
  146.                         (fx< (iob-offset iob) (iob-limit iob)))
  147.                    (set (text-elt extend i)
  148.                         (text-elt (iob-buffer iob) (iob-offset iob)))
  149.                    (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  150.                    (loop (fx+ i 1)))
  151.                    (else i)))))
  152.     (if (fx< offset size) 
  153.         (%vm-read-partial-block 
  154.          iob 
  155.          (make-extend-locative extend offset (fx- size offset))))))
  156.  
  157. (define (VM-CLEAR-BUFFER iob)
  158.   (set (iob-offset iob) (iob-limit iob)))
  159.  
  160. ;++ what about vm-read-8-u, vm-read-integer, etc. and likewise
  161. ;++ vm-write-8 ...
  162.  
  163.  
  164. ;;; Output
  165.  
  166. ;;; When a channel is closed it's limit is set to -1 so the test
  167. ;;; below fails on closed channels.
  168. ;;; Note: The only way for VPOS to advance is to use NEWLINE
  169.  
  170. (define-recursive (VM-WRITE-BYTE iob b)
  171.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  172.          (set (bref (iob-buffer iob) (iob-offset iob)) b)
  173.          (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  174.          (set (iob-h iob)      (fx+ (iob-h iob) 1))
  175.          (no-value))
  176.         (else
  177.          ((iob-overflow iob) iob 1)
  178.          (vm-write-byte iob b))))
  179.  
  180. (define-recursive (VM-WRITE-CHAR iob C)
  181.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  182.          (set (text-elt (iob-buffer iob) (iob-offset iob)) c)
  183.          (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  184.          (set (iob-h iob)      (fx+ (iob-h iob) 1))
  185.          (no-value))
  186.         (else
  187.          ((iob-overflow iob) iob 1)
  188.          (vm-write-char iob c))))
  189.  
  190. (define (VM-WRITE-SPACE iob)
  191.   (cond ((or (fx>= (iob-h iob) (iob-wrap-column iob))
  192.              (fx>= (iob-h iob) (iob-line-length iob)))
  193.          (vm-newline iob))
  194.         (else
  195.          (vm-write-char iob #\space))))
  196.  
  197. (define (VM-WRITE-SPACES PORT N)           ;; Hack for FORMAT.
  198.   (iterate loop ((i 0))
  199.     (cond ((fx>= i n) (no-value))
  200.           (else
  201.            (vm-write-space port)
  202.            (loop (fx+ i 1))))))
  203.  
  204. (define (VM-NEWLINE iob)
  205.   ;; IOB-H must be set below IOB-INDENT before any calls to VM-WRITE-CHAR.
  206.   ;; On some systems (Apollo) %VM-NEWLINE calls VM-WRITE-CHAR
  207.   ;; Note: IOB-INDENT must be less than IOB-WRAP-COLUMN.
  208.   (set (iob-h iob) 0)
  209.   (%vm-newline iob)
  210.   (if (iob-interactive? iob) (vm-force-output iob))
  211.   (set (iob-v iob) (fx+ (iob-v iob) 1))
  212.   (iterate loop ((i 0))
  213.     (cond ((fx< i (iob-indent iob))
  214.            (vm-write-char iob #\space)
  215.            (loop (fx+ i 1)))
  216.           (else
  217.            (set (iob-h iob) i) 
  218.            (no-value)))))
  219.  
  220. (define (VM-WRITE-FIXNUM IOB N RDX)
  221.   (labels (((write-fx n)
  222.             (cond ((fxN= n 0)
  223.                    (write-fx (fx/ n rdx))
  224.                    (let ((c (digit->char (fx-abs (fx-rem n rdx)) rdx)))
  225.                      (vm-write-char iob c))))))
  226.     (cond ((fx= n 0) (vm-write-char iob #\0))
  227.           (else
  228.            (if (fx< n 0) (vm-write-char iob negative-sign-char))
  229.            (write-fx n)))))
  230.  
  231.  
  232. ;;; VM-WRITE-STRING and VM-WRITE-TEXT could be speeded up, by using
  233. ;;; MOVE-TEXT instead of VM-WRITE-CHAR.  Does it matter?
  234.  
  235. ;++ these next three can be flushed since they're handled by the
  236. ;++ default ops.
  237.  
  238. (define (VM-WRITE-STRING IOB STR)
  239.   (let ((len (string-length str)))
  240.     (iterate loop ((i 0))
  241.       (cond ((fx>= i len) (no-value))
  242.             (else
  243.              (vm-write-char iob (string-elt str i))
  244.              (loop (fx+ 1 i)))))))
  245.  
  246. (define (VM-WRITE-TEXT IOB TEXT COUNT)
  247.   (iterate loop ((i 0))
  248.     (cond ((fx>= i count) (no-value))
  249.           (else
  250.            (vm-write-char iob (text-elt text i))
  251.            (loop (fx+ 1 i))))))
  252.  
  253. (define (VM-WRITE-BLOCK IOB EXTEND OFFSET LENGTH)
  254.   (let ((loc (make-extend-locative extend offset length)))
  255.     (%vm-write-buffer iob)
  256.     (%vm-write-block iob loc)))
  257.  
  258. (define (VM-FORCE-OUTPUT IOB)
  259.   (%vm-write-buffer iob)
  260.   (if (not (iob-interactive? iob)) (%vm-force-output iob))
  261.   (no-value))
  262.  
  263. ;;; File access.
  264.  
  265. (define (OPEN-PORT FILESPEC MODESPEC)
  266.   (iterate loop ((fname filespec))
  267.     (let ((val (%vm-open-file 'open-port
  268.                               fname
  269.                               modespec
  270.                               default-buffer-size)))
  271.       (cond ((iob? val) val)
  272.             (else
  273.              (receive vals
  274.                       (error "(OPEN '~s '~s) failed - ~%~
  275.                              **~10t [VM - ~s]~%~
  276.                              **~10t Type (RET) or (RET filespec) to retry."
  277.                              fname 
  278.                              modespec 
  279.                              (local-os-error-message val))
  280.                (if (null? vals) 
  281.                    (loop filespec)
  282.                    (loop (car vals)))))))))
  283.  
  284. (define (MAYBE-OPEN-PORT FILESPEC MODESPEC)
  285.   (let ((mode (mode->iob-mode 'maybe-open-port filespec modespec)))
  286.   ;++ temp gross hack
  287.     (cond ((iob-mode? mode iob/retrieve)
  288.            (maybe-open-retrieve-file filespec))
  289.           ((iob-mode? mode iob/dump)
  290.            (maybe-open-dump-file filespec))
  291.           (else
  292.            (let ((val (%vm-open-file 'maybe-open-port
  293.                                      filespec
  294.                                      modespec
  295.                                      default-buffer-size)))
  296.              (if (iob? val) val '#f))))))
  297.     
  298. ;++ should this do an implicit close?
  299. (define (RE-OPEN-PORT! PORT MODESPEC)
  300.   (cond ((not (iob-closed? port))
  301.          (error "attempt to re-open an open file ~a" port))
  302.         ((eq? 'anonymous (iob-id port))    
  303.          (error "attempt to re-open an anonomous file ~a" port))
  304.         (else                          
  305.          (open-port port modespec)))
  306.   (no-value))
  307.  
  308. ;;; When a iob is closed it's limit is set to -1 so that it will
  309. ;;; fail the first test in VM-READ-CHAR, VM-READ-BYTE, VM-WRITE-CHAR, 
  310. ;;; and VM-WRITE-BYTE the
  311. ;;; overflow code will then generate a closed IOB error.
  312.  
  313. (define (CLOSE-PORT iob)
  314.   (let ((iob (enforce iob? iob)))
  315.     (cond ((iob-permanent? iob)
  316.            (nc-error "attempt to close a permanent port - ~a" iob))
  317.           ((iob-closed? iob)
  318.            (no-value))
  319.           (else
  320.            (if (iob-writable? iob) (%vm-write-buffer iob))
  321.            (if (iob-channel iob) (%vm-close-file iob))
  322.         ;++(set (table-entry open-port-table iob) nil)
  323.            (release-buffer-text %buffer-pool iob)
  324.            (set (iob-buffer iob) '#f)
  325.            (set (iob-mode   iob) iob/closed)
  326.            (set (iob-xeno   iob) '#f)
  327.            ;; make it fail in VM-READ-CHAR
  328.            (set (iob-limit  iob) -1)
  329.            (no-value)))))
  330.  
  331.  
  332. (define (with-open-ports-handler proc . openers)
  333.   (let ((ports '()))
  334.     (unwind-protect
  335.      (block (walk (lambda (opener) (push ports (opener)))
  336.                   ;; careful - don't use map here!
  337.                   openers)
  338.             ;; thanks to nat for the (set ports ...)
  339.             (apply proc (set ports (reverse! ports))))
  340.      (walk (lambda (port)
  341.              ;; deal with maybe-open.
  342.              (cond (port 
  343.                     (close port)
  344.                     (if (iob? port) (release-buffer port)))))
  345.            ports))))
  346.  
  347. (define (file-exists? filespec)
  348.   (let ((val nil))
  349.     (unwind-protect
  350.       (let ()
  351.         (set val (maybe-open-port filespec 'inquire))
  352.         (if val t nil))
  353.       (if val (close-port val)))))
  354.  
  355. ;;; Standard I/O ports
  356.  
  357. ;;; E.g. (READ (STANDARD-INPUT))
  358. ;;; (BIND (((TERMINAL-INPUT) FOO-port)) ...)
  359.  
  360. (define-simple-switch standard-input  input-port?)
  361. (define-simple-switch standard-output output-port?)
  362. (define-simple-switch standard-i/o    port?)
  363.  
  364. (define-simple-switch error-input     input-port?)
  365. (define-simple-switch error-output    output-port?)
  366. (define-simple-switch error-i/o       port?)
  367.  
  368. (define-simple-switch terminal-input  input-port?)
  369. (define-simple-switch terminal-output output-port?)
  370. (define-simple-switch terminal-i/o    port?)
  371.  
  372. (define-simple-switch debug-input     input-port?)
  373. (define-simple-switch debug-output    output-port?)
  374. (define-simple-switch debug-i/o       port?)
  375.  
  376. (define-simple-switch crawl-input     input-port?)
  377. (define-simple-switch crawl-output    output-port?)
  378. (define-simple-switch crawl-i/o       port?)
  379.  
  380.  
  381. (define (initialize-standard-ports)
  382.   (set (standard-input)  (create-iob 'standard-input
  383.                                      %%standard-input
  384.                                      (fx-ior iob/read
  385.                                              (fx-ior iob/interactive
  386.                                                      iob/permanent))
  387.                                      512))
  388.   (set (standard-output) (create-iob 'standard-output
  389.                                      %%standard-output
  390.                                      (fx-ior iob/write
  391.                                              (fx-ior iob/interactive
  392.                                                      iob/permanent))
  393.                                      512))
  394.   (set (standard-i/o)    (join (standard-input) (standard-output)))
  395.  
  396.   (set (error-input)     (standard-input))
  397.   (set (error-output)    (standard-output))
  398.   (set (error-i/o)       (join (error-input) (error-output)))
  399.  
  400.   (set (terminal-input)  (standard-input))
  401.   (set (terminal-output) (standard-output))
  402.   (set (terminal-i/o)    (join (terminal-input) (terminal-output)))
  403.  
  404.   (set (debug-input)     (error-input))
  405.   (set (debug-output)    (error-output))
  406.   (set (debug-i/o)       (join (debug-input) (debug-output)))
  407.  
  408.   (set (crawl-input)     (standard-input))
  409.   (set (crawl-output)    (standard-output))
  410.   (set (crawl-i/o)       (join (crawl-input) (crawl-output)))
  411.     )
  412.  
  413.  
  414. ;;; Hack for no apparent reason.
  415.  
  416. (define-constant null-port
  417.   (object nil
  418.     ((read-char self)      eof)
  419.     ((unread-char self)    (no-value))
  420.     ((write-char self ch)  (ignore ch) (no-value))
  421.     ((input-port? self)  '#t)
  422.     ((output-port? self) '#t)
  423.     ((port? self)        '#t)
  424.     ((print self port) (format port "#{Null port}"))))
  425.  
  426. ;;; GC hook: arrange to close open ports for ports to which
  427. ;;; there are no pointers.
  428.  
  429. ;(define (gc-close-unreferenced-ports)
  430. ; (walk-table open-port-table
  431. ;             (lambda (port h)
  432. ;               (cond ((not (object-unhash h))
  433. ;                      (close-port port)
  434. ;                      (gc-message "port closed: ~s~%" port))))))
  435.  
  436. ;;; If *POST-GC-AGENDA* doesn't have at least one element, then
  437. ;;; we're really losing.
  438.  
  439. ;++ why not move this stuff to gc-aux.t
  440. ;(append! *post-gc-agenda*
  441. ;         (list (cons 'gc-close-unreferenced-ports
  442. ;                     gc-close-unreferenced-ports)))
  443.  
  444.  
  445.  
  446. ;++ move this to the appropriate place someday
  447. (initialize-standard-ports)
  448.